C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  ISTDC - DATA COMPARISON PROGRAM
C          A TIE CONFORMING DATA COMPARISON TOOL GENERATED FROM THE
C            'COMPARE' UTILITY CREATED AT BRADFORD UNIVERSITY
C            BY PETER JEWELL AT THE UNIVERSITY OF BRADFORD.
C
C------------------------------------------------------------------------
C
C
      PROGRAM ISTDC
C
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
      CHARACTER SPACE, UPARW
      PARAMETER (UPARW='^',SPACE=' ')
C     ..
C     .. Scalars in Common ..
      INTEGER II1,II2,L1TOT,L2TOT,LEN1,LEN2,LT1,LT2,
     +        NERROR
      LOGICAL EXACT, VERBOS
      CHARACTER*(LINLEN) A,B,LINE1,LINE2
C     ..
C     .. Arrays in Common ..
      DOUBLE PRECISION T(3)
      INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
C     ..
C     .. Local Scalars ..
      REAL TT
      INTEGER I,I1,I2,I2SV,K,K1,K2,KA,KB,KOUNT,LINERR,LNFLAG,LTOT,LTOT1,
     +        LTOT2,MAXFWD,MISAL,N,TEST,TEMP1,TEMP2,OFFSET,TMP
      LOGICAL ENDF1,ENDF2,FIRST,HEADER,NUMBER,OK,PRINT,SPNULL,MATCH,
     +        FOLD
      CHARACTER S,MARKER*4,NAME*7,VAL*7,POINT1* (LINLEN),
     +          POINT2* (LINLEN)
C     ..
C     .. Local Arrays ..
      INTEGER MIS1(3),MIS2(3), BUFFER(134), STDPTH(81),
     +        OUTPTH(81), CMPPTH(81)
C     ..
C     .. External Functions ..
      INTEGER CREATE,GETARG,OPEN,READS
      LOGICAL SAME
      EXTERNAL CREATE,GETARG,OPEN,READS,SAME
C     ..
C     .. External Subroutines ..
      EXTERNAL CHKNUM,ERROR,LISTF2,PUTCH,PUTLIN,SEARCH,SHRINK,ZCHOUT,
     +         ZINIT,ZMESS,ZPTINT,ZPTMES,ZPUTCH,ZQUIT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,MAX,SIGN
C     ..
C     .. Common blocks ..
      COMMON LEN1,LEN2,L1TOT,L2TOT,KEY1,KEY2,LT1,LT2
      COMMON /B1/LINE1,LINE2,A,B
      COMMON /B2/KEYA,KEYB
      COMMON /ONLNE/II1,II2,NERROR,EXACT
      COMMON /TOLS/T
      COMMON /OPTSC/ MARKER
      COMMON /OPTSI/ MAXFWD, SPNULL, HEADER, FOLD, VERBOS
C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
C  PROVIDE PORTABLE RECORD BACKSPACING.
C
C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
C             FROM A READS CALL FOR EACH FILE
C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
C             EACH FILE
C  SAVLIN     SAVED LINES FOR EACH FILE
C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
C  INFO(2..)  THE LINE NUMBER
C
      INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
      COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
      CHARACTER*134  SAVLIN(100, 2)
      COMMON /STACKC/ SAVLIN
      SAVE
C     ..
 
      DATA (MIS1(I),I=1,3)/-2,-2,-2/
      DATA (MIS2(I),I=1,3)/-2,-2,-2/
C
C  READING AND ANALYSING PARAMETERS
C     ..
      CALL ZINIT
 
      IF(GETARG(1, STDPTH, 81) .EQ. -100) CALL NAMES(1, STDPTH)
      IF(GETARG(2, CMPPTH, 81) .EQ. -100) CALL NAMES(2, CMPPTH)
      IF(GETARG(3, OUTPTH, 81) .EQ. -100) CALL NAMES(3, OUTPTH)
      FDS(1) = OPEN(STDPTH, 0)
      FDS(2) = OPEN(CMPPTH, 0)
      FDS(3) = CREATE(OUTPTH, 1)
      DO 10 I = 1, 3
        IF(FDS(I) .EQ. -1) CALL ERROR('FILE ERROR.')
   10 CONTINUE
      DO 11 I = 4, 10
        IF(GETARG(I, BUFFER, 132) .NE. -100) CALL IDOPS(BUFFER)
   11 CONTINUE
C
      IF (HEADER) THEN
        CALL ZMESS('------- DATA COMPARISON PROGRAM --------.', FDS(3))
        CALL PUTCH(10, FDS(3))
        CALL ZCHOUT('STANDARD FILE  : .', FDS(3))
        CALL ZPTMES(STDPTH, FDS(3))
        CALL ZCHOUT('COMPARISON FILE: .', FDS(3))
        CALL ZPTMES(CMPPTH, FDS(3))
        CALL PUTCH(10, FDS(3))
 
        IF (SPNULL) THEN
          CALL ZMESS(' - SPACES ARE BEING IGNORED.', FDS(3))
        ELSE
          CALL ZMESS(' - SPACES ARE SIGNIFICANT.', FDS(3))
        END IF
        IF (FOLD) THEN
          CALL ZMESS(' - CHARACTER CASE IS BEING IGNORED.', FDS(3))
        ELSE
          CALL ZMESS(' - CHARACTER CASE IS SIGNIFICANT.', FDS(3))
        END IF
        IF (EXACT) THEN
          CALL ZMESS(' - NUMERIC VALUES MUST MATCH EXACTLY.', FDS(3))
        ELSE
          CALL ZCHOUT(' - VALUES WILL BE LIMITED TO BETWEEN .', FDS(3))
          CALL OUTREL(T(1), FDS(3))
          CALL ZCHOUT(' AND .', FDS(3))
          CALL OUTREL(T(3), FDS(3))
          CALL PUTCH(10, FDS(3))
          CALL ZCHOUT
     +         ('   AND WILL BE TESTED TO A TOLERANCE OF .', FDS(3))
          CALL OUTREL(T(2), FDS(3))
          CALL PUTCH(10, FDS(3))
        END IF
 
        CALL PUTCH(10, FDS(3))
        CALL ZMESS('IF MIS-ALIGNMENT  OCCURS THE PROGRAM WILL.',FDS(3))
        CALL ZMESS('SEARCH FORWARD IN BOTH FILES UNTIL ONE OF.',FDS(3))
        CALL ZMESS('THE FOLLOWING CONDITIONS IS MET:- .',FDS(3))
 
        CALL ZCHOUT('    THE 4 CHARACTER STRING ".',FDS(3))
        DO 12 I = 1,4
   12   CALL ZPUTCH(MARKER(I:I), FDS(3))
        CALL ZMESS('" IS MET AT THE START OF A LINE.',FDS(3))
        CALL ZMESS('    THE END OF INPUT IS REACHED  .',FDS(3))
        CALL ZCHOUT('    .',FDS(3))
        CALL ZPTINT(MAXFWD,1,FDS(3))
        CALL ZMESS(' LINES HAVE BEEN EXAMINED.',FDS(3))
        CALL PUTCH(10, FDS(3))
C
      END IF
C**************************
C   START OF ACTUAL PROGRAM
C**************************
      OK     = .TRUE.
      ENDF1  = .FALSE.
      ENDF2  = .FALSE.
      FIRST  = .TRUE.
      PRINT  = .TRUE.
      MATCH  = .TRUE.
      MISAL  = 0
      KOUNT  = 0
      LINERR = 0
      LINE1  = ' '
      LINE2  = ' '
C  SET UP INPUT BUFFERING
      NXTIN(1)  = 1
      NXTLIN(1) = 1
      NXTOUT(1) = 1
      NXTIN(2)  = 1
      NXTLIN(2) = 1
      NXTOUT(2) = 1
C  GIVEN RESULTS 3 (STANDARD FILE).
   30 CONTINUE
      LEN1 = READS(1, LINE1,I1)
      IF(LEN1 .EQ. -100) GO TO 180
      IF (LEN1.EQ.0 .OR. ENDF2) GO TO 30
C  CALCULATED RESULTS 4 (COMPARISON FILE).
   40 CONTINUE
      LEN2 = READS(2, LINE2,I2)
      IF(LEN2 .EQ. -100) GO TO 210
      IF (LEN2.EQ.0 .OR. ENDF1) GO TO 40
      IF ((I1.EQ.MIS1(1).AND.I2.EQ.MIS2(1)) .OR.
     +    (I1.EQ.MIS1(2).AND.I2.EQ.MIS2(2)) .OR.
     +    (I1.EQ.MIS1(3).AND.I2.EQ.MIS2(3))) THEN
        KOUNT = KOUNT + 1
        GO TO 40
 
      END IF
 
      NERROR = 0
      A      = SPACE
      B      = SPACE
      POINT1 = SPACE
      POINT2 = SPACE
      LNFLAG = 0
      K1     = 1
      K2     = 1
      LT1    = 0
      LT2    = 0
      NUMBER = .TRUE.
C  IF SPACES ARE TO BE IGNORED SPNULL=.TRUE.
      IF (SPNULL) THEN
        CALL SHRINK
 
      ELSE
        A      = LINE1
        B      = LINE2
        L1TOT  = LEN1
        L2TOT  = LEN2
        DO 50 I = 1,LEN1
          KEYA(I)  = I
          KEY1(I)  = I
   50   CONTINUE
        DO 60 I = 1,LEN2
          KEYB(I)  = I
          KEY2(I)  = I
   60   CONTINUE
      END IF
 
      IF (L1TOT.EQ.L2TOT) GO TO 70
      IF (L1TOT.LT.L2TOT) LNFLAG = -1
      IF (L1TOT.GT.L2TOT) LNFLAG = 1
*
C  IS IT AT END OF EITHER OR BOTH LINES ?
   70 CONTINUE
      IF(K1 .GT. L1TOT .OR. K2 .GT. L2TOT) THEN
        NERROR = NERROR + L1TOT - K1 + L2TOT - K2 + 2
        IF (NERROR.EQ.0) THEN
C  NO MISALIGNMENT.
          MISAL  = 0
          KOUNT  = 0
          FIRST  = .TRUE.
          PRINT  = .TRUE.
          IF ( .NOT. MATCH) THEN
C  BACKSPACE AND LIST LINES IN F2 THAT DO NOT ALIGN.
            TMP=I2
            IF((MIS2(1).LT.I2) .AND. VERBOS) CALL LISTF2(MIS2(1),TMP,I2)
            II1    = I1
            II2    = I2
            CALL ZMESS('FILES REALIGNED AT:.', FDS(3))
            CALL ZCHOUT('   .', FDS(3))
            CALL PUTLIN(STDPTH, FDS(3))
            CALL ZCHOUT(' LINE: .', FDS(3))
            CALL ZPTINT(I1, 1, FDS(3))
            CALL PUTCH(10, FDS(3))
            CALL ZCHOUT('   .', FDS(3))
            CALL PUTLIN(CMPPTH, FDS(3))
            CALL ZCHOUT(' LINE: .', FDS(3))
            CALL ZPTINT(I2, 1, FDS(3))
            CALL PUTCH(10, FDS(3))
            MATCH  = .TRUE.
          END IF
 
          GO TO 30
 
        END IF
 
        LTOT   = L1TOT + L2TOT
C  CHECK MISALIGNMENT - IF ONE RECORD IS TWICE AS LONG AS THE OTHER OR
C  FAILING THIS, IF LARGE PROPORTION OF ERRORS ON REASONABLE
C  SIZED RECORD.
        IF (ABS(L1TOT-L2TOT).LE.0.5*MAX(L1TOT,L2TOT)) THEN
          IF ( .NOT. MATCH) THEN
C  REALIGNMENT TEST STRICTER THAN MISALIGNMENT TEST.
C  ARE FILES REALIGNED ?
            IF (LTOT.GE.34 .AND. (LTOT-NERROR).GE.0.7059*LTOT) THEN
C  FILES ALIGNED AGAIN.
C  BACKSPACE AND LIST LINES IN F2 THAT DO NOT ALIGN.
              TMP=I2
              IF(MIS2(1).LT.I2 .AND. VERBOS) CALL LISTF2(MIS2(1),TMP,I2)
              II1    = I1
              II2    = I2
              CALL ZMESS('FILES REALIGNED AT:.', FDS(3))
              CALL ZCHOUT('   .', FDS(3))
              CALL PUTLIN(STDPTH, FDS(3))
              CALL ZCHOUT(' LINE: .', FDS(3))
              CALL ZPTINT(I1, 1, FDS(3))
              CALL PUTCH(10, FDS(3))
              CALL ZCHOUT('   .', FDS(3))
              CALL PUTLIN(CMPPTH, FDS(3))
              CALL ZCHOUT(' LINE: .', FDS(3))
              CALL ZPTINT(I2, 1, FDS(3))
              CALL PUTCH(10, FDS(3))
              MATCH  = .TRUE.
              MISAL  = 0
              KOUNT  = 0
              FIRST  = .TRUE.
              PRINT  = .TRUE.
            END IF
C  ARE FILES MISALIGNED ?
          ELSE IF ((LTOT.GE.34.AND.NERROR.GT.0.88235*LTOT) .OR.
     +             (LTOT.GE.8.AND.NERROR.EQ.LTOT)) THEN
C  APPARENT MISALIGNMENT (LARGE NUMBER OF ERRORS).
            MATCH = .FALSE.
 
          ELSE
C  SOME ERRORS BUT INSUFFICIENT FOR MISALIGNMENT.
            MISAL  = 0
            KOUNT  = 0
          END IF
 
        ELSE
C  APPARENT MISALIGNMENT (ONE LINE MUCH LONGER THAN OTHER).
          MATCH  = .FALSE.
        END IF
 
        IF ( .NOT. PRINT) GO TO 100
C  IF NOT AT END OF BOTH LINES SET POINTERS TO REMAINING CHARACTERS.
        IF(.NOT. (K1 .GT. L1TOT .AND. K2 .GT. L2TOT)) THEN
          IF (K1.GT.L1TOT) THEN
            DO 80 I = K2,L2TOT
              POINT2(KEY2(I) :KEY2(I))  = UPARW
   80       CONTINUE
 
          ELSE
            DO 90 I = K1,L1TOT
              POINT1(KEY1(I) :KEY1(I))  = UPARW
   90       CONTINUE
          END IF
 
        END IF
 
          II1    = I1
          II2    = I2
          CALL ZMESS('-----------------.', FDS(3))
          CALL ZPTINT(NERROR, 1, FDS(3))
          IF(NERROR .EQ. 1) THEN
            CALL ZMESS(' DIFFERENCE REPORTED AT:-.', FDS(3))
          ELSE
            CALL ZMESS(' DIFFERENCES REPORTED AT:-.', FDS(3))
          END IF
          CALL ZCHOUT('   .', FDS(3))
          CALL PUTLIN(STDPTH, FDS(3))
          CALL ZCHOUT(' LINE: .', FDS(3))
          CALL ZPTINT(I1, 1, FDS(3))
          CALL PUTCH(10, FDS(3))
          CALL ZCHOUT('   .', FDS(3))
          CALL PUTLIN(CMPPTH, FDS(3))
          CALL ZCHOUT(' LINE: .', FDS(3))
          CALL ZPTINT(I2, 1, FDS(3))
          CALL PUTCH(10, FDS(3))
          LINERR = LINERR + 1
 
        IF (LNFLAG.NE.0) THEN
          IF(VERBOS) THEN
            CALL ZCHOUT('LINES DO NOT CONTAIN THE SAME .', FDS(3))
            CALL ZMESS ('NUMBER OF SIGNIFICANT CHARACTERS...', FDS(3))
          ENDIF
          N      = L2TOT - L1TOT
          II1    = ABS(N)
        END IF
        DO 98 I = 1, LEN1
   98   CALL ZPUTCH(LINE1(I:I), FDS(3))
        CALL PUTCH(10, FDS(3))
        IF(VERBOS) CALL ZMESS(POINT1(1:LEN1), FDS(3))
        DO 99 I = 1, LEN2
   99   CALL ZPUTCH(LINE2(I:I), FDS(3))
        CALL PUTCH(10, FDS(3))
        IF(VERBOS) CALL ZMESS(POINT2(1:LEN2), FDS(3))
  100   CONTINUE
        OK     = .FALSE.
        IF (MATCH) THEN
          GO TO 30
 
        ELSE
C  RECORDS NOT ALIGNED.
          MISAL  = MISAL + 1
          KOUNT  = KOUNT + 1
          IF (PRINT .AND. VERBOS) THEN
            IF(MISAL .EQ. 1) THEN
              CALL ZMESS(' (FIRST LINE MISALIGNMENT).', FDS(3))
            ELSE IF(MISAL .EQ. 2) THEN
              CALL ZMESS(' (SECOND LINE MISALIGNMENT).', FDS(3))
            ELSE
              CALL ZMESS(' (THIRD LINE MISALIGNMENT).', FDS(3))
            ENDIF
          ENDIF
          IF (MISAL.LE.2) THEN
C  SAVE POSITIONS OF POSSIBLE MISALIGNED RECORDS.
            MATCH  = .TRUE.
            MIS1(MISAL)  = I1
            MIS2(MISAL)  = I2
            GO TO 30
 
          ELSE IF (MISAL.EQ.3) THEN
C  DECIDED MISALIGNMENT HAS OCCURRED,
C  SWITCH OFF PRINTING,
C  BACKSPACE F1 AND F2 READY TO START CROSS CHECKING.
            MIS1(MISAL)  = I1
            MIS2(MISAL)  = I2
            PRINT  = .FALSE.
            KOUNT  = 1
            CALL BSPACE(1, MIS1(1))
            I1     = MIS1(1) - 1
            CALL BSPACE(2, MIS2(1)+1)
            I2     = MIS2(1)
            II1    = MIS1(1)
            II2    = MIS2(1)
            CALL ZMESS('-----------------.', FDS(3))
            CALL ZMESS('FILES MISALIGNED AT:.', FDS(3))
            CALL ZCHOUT('   .', FDS(3))
            CALL PUTLIN(STDPTH, FDS(3))
            CALL ZCHOUT(' LINE: .', FDS(3))
            CALL ZPTINT(II1, 1, FDS(3))
            CALL PUTCH(10, FDS(3))
            CALL ZCHOUT('   .', FDS(3))
            CALL PUTLIN(CMPPTH, FDS(3))
            CALL ZCHOUT(' LINE: .', FDS(3))
            CALL ZPTINT(II2, 1, FDS(3))
            CALL PUTCH(10, FDS(3))
 
          ELSE
C  ADVANCE F2 LOOKING FOR ALIGNMENT.
            IF (KOUNT.LE.MAXFWD .AND. LINE2(1:4).NE.MARKER) GO TO 40
C  ADVANCED F2 TO LIMIT, ADVANCE F1 AND
C  BACKSPACE F2 TO START OF MISALIGNMENT.
            IF (FIRST .AND. VERBOS) THEN
              CALL ZCHOUT('THE FOLLOWING LINES ARE NOT .', FDS(3))
              CALL ZMESS('ALIGNED (STANDARD):.', FDS(3))
              FIRST  = .FALSE.
            END IF
            IF(VERBOS) THEN
              DO 101 I = 1, LEN1
  101         CALL ZPUTCH(LINE1(I:I), FDS(3))
              CALL PUTCH(10, FDS(3))
            ENDIF
            CALL BSPACE(2, MIS2(1) + 1)
            I2SV   = I2
            I2     = MIS2(1) - 1
            KOUNT  = 0
          END IF
 
          GO TO 30
 
        END IF
*
C  NOT AT END OF EITHER LINE.
      ELSE
C  CHECK IF NEXT ITEM ON EACH LINE IS A NUMBER,
C  IF IT IS, ARE THEY EQUAL TO GIVEN TOLERANCE?
        KA     = K1
        KB     = K2
        IF (NUMBER .AND. (K1 .GT. LT1 .OR. K2 .GT. LT2)
     +     .AND. .NOT. EXACT)
     +     CALL CHKNUM(K1, K2, *70, NUMBER)
C  NEXT ITEMS WERE NUMERIC BUT NOT EQUAL,
C  OR NON NUMERIC.
        IF (SAME(K1,K2)) THEN
          IF(K1 .GT. LT1 .OR. K2 .GT. LT2) NUMBER = .TRUE.
          GO TO 70
 
        END IF
C  KA,KB POINT AT NON CONCURRENT CHARACTERS
        KA     = K1 - 1
        KB     = K2 - 1
C  SEARCH FINDS NEXT PAIR OF CHARACTERS THAT AGREE(IN K1 & K2) -
C   IF POSSIBLE, OR SETS K1,K2 TO LT1+1,LT2+1
        CALL SEARCH(K1,K2)
C  POINT AT DISAGREEING CHARACTERS.
        DO 140 I = KA,K1 - 1
          POINT1(KEY1(I) :KEY1(I))  = UPARW
  140   CONTINUE
        DO 150 I = KB,K2 - 1
          POINT2(KEY2(I) :KEY2(I))  = UPARW
  150   CONTINUE
        NERROR = NERROR + (K1-KA) + (K2-KB)
C  IF AT END OF WORD OF CHARACTERS SKIP ANY REMAINING CHARACTERS IN WORD
C  AND SET THESE AS ERROR CHARACTERS.
        IF(K1+1 .GT. LT1 .OR. K2+1 .GT. LT2) THEN
          NUMBER = .TRUE.
          DO 160 I = K1 + 1,LT1
            POINT1(KEY1(I) :KEY1(I))  = UPARW
  160     CONTINUE
          DO 170 I = K2 + 1,LT2
            POINT2(KEY2(I) :KEY2(I))  = UPARW
  170     CONTINUE
          IF (K1.LT.LT1) NERROR = NERROR + LT1 - K1
          IF (K2.LT.LT2) NERROR = NERROR + LT2 - K2
          K1     = LT1 + 1
          K2     = LT2 + 1
 
        ELSE
C  WHEN NOT AT END OF WORD INCREMENT CHARACTER COUNTERS.
          K1     = K1 + 1
          K2     = K2 + 1
        END IF
 
      END IF
 
      GO TO 70
*
C  END OF FILE1 REACHED
  180 CONTINUE
      ENDF1  = .TRUE.
      IF (ENDF2) GO TO 240
      IF ( .NOT. MATCH) THEN
C  END OF F1 REACHED BUT NOT F2 AND IN MISALIGNMENT
C  SO LIST ALL LINES IN F2 FROM LAST ALIGNMENT
        CALL LISTF2(MIS2(1),-I2SV, I2)
 
      ELSE
C  END OF F1 REACHED BUT NOT F2 AND NOT IN MISALIGNED SITUATION
C  READ TO END OF F2 PRINTING NON BLANK LINES
C  NEXT LINE IN F2 SHOULD BE END OF FILE IF OK.
C  NON BLANK LINES ARE COUNTED IN ERROR COUNT
  190   CONTINUE
        TEMP2 = READS(2, LINE2, I2)
        IF(TEMP2 .EQ. -100) GO TO 210
        IF (TEMP2.EQ.0) GO TO 190
        LINERR = LINERR + 1
        OK     = .FALSE.
        CALL PUTCH(10, FDS(3))
        CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
        CALL ZMESS('FOLLOWING LINES LEFT IN COMPARISON FILE.', FDS(3))
        DO 199 I = 1, TEMP2
  199   CALL ZPUTCH(LINE2(I:I), FDS(3))
        CALL PUTCH(10, FDS(3))
  200   CONTINUE
        TEMP2 = READS(2, LINE2, I2)
        IF(TEMP2 .EQ. -100) GO TO 210
        IF (TEMP2.NE.0) THEN
          DO 198 I = 1, TEMP2
  198     CALL ZPUTCH(LINE2(I:I), FDS(3))
          CALL PUTCH(10, FDS(3))
          LINERR = LINERR + 1
        END IF
 
        GO TO 200
 
      END IF
 
      GO TO 40
*
C  END OF FILE2 REACHED
C  IF MISALIGNED AND END OF F2 REACHED ADVANCE F1 ONE RECORD
C  AND BACKSPACE F2 TO POINT WHERE MISALIGNMENT TOOK PLACE.
  210 CONTINUE
      IF (MISAL.GE.3 .AND. .NOT. ENDF1) THEN
        IF (FIRST .AND. VERBOS) THEN
          CALL ZCHOUT('THE FOLLOWING LINES ARE NOT .', FDS(3))
          CALL ZMESS('ALIGNED (STANDARD):.', FDS(3))
          FIRST  = .FALSE.
        END IF
        IF(VERBOS) THEN
          DO 197 I = 1, LEN1
  197     CALL ZPUTCH(LINE1(I:I), FDS(3))
          CALL PUTCH(10, FDS(3))
        ENDIF
 
        CALL BSPACE(2, MIS2(1)+1)
        I2SV   = I2
        I2     = MIS2(1) - 1
        KOUNT  = 0
        GO TO 30
 
      ELSE IF ( .NOT. ENDF1) THEN
C  END OF F2 REACHED BUT NOT F1 AND NOT MISALIGNED
C  READ TO END OF F1 PRINTING NON BLANK LINES
C  FIRST LINE HAS ALREADY BEEN READ IN LINE1
        ENDF2  = .TRUE.
        OK     = .FALSE.
        CALL PUTCH(10, FDS(3))
        CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
        CALL ZMESS('FOLLOWING LINES LEFT IN STANDARD FILE.', FDS(3))
        DO 196 I = 1, LEN1
  196   CALL ZPUTCH(LINE1(I:I), FDS(3))
        CALL PUTCH(10, FDS(3))
        LINERR = LINERR + 1
  230   CONTINUE
        TEMP1 = READS(1, LINE1,I1)
        IF(TEMP1 .EQ. -100) GO TO 180
        IF (TEMP1.NE.0) THEN
          DO 195 I = 1, TEMP1
  195     CALL ZPUTCH(LINE1(I:I), FDS(3))
          CALL PUTCH(10, FDS(3))
          LINERR = LINERR + 1
        END IF
 
        GO TO 230
 
      END IF
 
      ENDF2  = .TRUE.
  240 CONTINUE
      IF (ENDF1) THEN
        LTOT1  = I1
        LTOT2  = I2
        IF (I1.NE.I2) THEN
          II1    = I1
          II2    = I2
          CALL PUTCH(10, FDS(3))
          CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
          CALL ZMESS('FILES ARE DIFFERENT LENGTHS.', FDS(3))
 
        ELSE IF (OK) THEN
          CALL PUTCH(10, FDS(3))
          CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
          CALL ZMESS('[ISTDC files are identical].', 1)
          CALL ZQUIT(-2)
 
        END IF
 
      ELSE
        GO TO 30
 
      END IF
 
      II1    = LINERR
      CALL ZPTINT(LINERR, 1, FDS(3))
      CALL ZMESS(' LINES ARE DIFFERENT.', FDS(3))
      CALL ZMESS('[ISTDC files are different].', 1)
      CALL ZQUIT(-2)
*
      END
C-----------------------------------------------------------------------
      BLOCK DATA BISTDC
C
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
C     ..
C     .. Scalars in Common ..
      LOGICAL COM,    LBRKT,  SPNULL,  HEADER, EXACT,
     +        FOLD,   VERBOS
      INTEGER II1,    II2,    NERROR,  MAXFWD
      CHARACTER *4        MARKER
C     ..
C     .. Arrays in Common ..
      DOUBLE PRECISION T(3)
      INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
C     ..
C     .. Local Scalars ..
      INTEGER I
C     ..
C     .. Common blocks ..
      COMMON /ONLNE/  II1,II2,NERROR,EXACT
      COMMON /TOLS/   T
      COMMON /OPTSC/  MARKER
      COMMON /OPTSI/  MAXFWD, SPNULL, HEADER, FOLD, VERBOS
      COMMON /ZFRDSV/ LBRKT, COM
C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
C  PROVIDE PORTABLE RECORD BACKSPACING.
C
C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
C             FROM A READS CALL FOR EACH FILE
C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
C             EACH FILE
C  SAVLIN     SAVED LINES FOR EACH FILE
C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
C  INFO(2..)  THE LINE NUMBER
C
      INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
      COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
      CHARACTER*134  SAVLIN(100, 2)
      COMMON /STACKC/ SAVLIN
      SAVE
C     ..
      DATA (INFO(2, I, 1),I=1, 100) /100 * 0/
      DATA (INFO(2, I, 2),I=1, 100) /100 * 0/
      DATA COM/.FALSE./ ,LBRKT/.FALSE./, FOLD/.FALSE./
      DATA MAXFWD/20/
      DATA MARKER/'.+-.'/,HEADER/.TRUE./, VERBOS/.TRUE./
      DATA T/1.0D-10,1.0D-6,1.0D10/
      DATA SPNULL,EXACT/.TRUE.,.FALSE./
 
      END
C----------------------------------------------
      SUBROUTINE CHKNUM(K1,K2,*,NUM)
*
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
C     ..
C     .. Scalar Arguments ..
      INTEGER K1,K2
      LOGICAL NUM
C     ..
C     .. Scalars in Common ..
      DOUBLE PRECISION TOL1,TOL2,TOL3
      INTEGER L1TOT,L2TOT,LEN1,LEN2,LT1,LT2
      CHARACTER * (LINLEN)  A1,B2,LINE1,LINE2
C     ..
C     .. Arrays in Common ..
      INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION A,B
      INTEGER KA,KB
      LOGICAL EOR
C     ..
C     .. External Subroutines ..
      EXTERNAL FREAD
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS
C     ..
C     .. Common blocks ..
      COMMON LEN1,LEN2,L1TOT,L2TOT,KEY1,KEY2,LT1,LT2
      COMMON /B1/LINE1,LINE2,A1,B2
      COMMON /B2/KEYA,KEYB
      COMMON /TOLS/TOL1,TOL2,TOL3
      SAVE
C     ..
      EOR    = .FALSE.
      KA     = KEY1(K1)
      KB     = KEY2(K2)
      CALL FREAD(LINE1(1:LEN1),KA,A,*30,*50)
   10 CONTINUE
      CALL FREAD(LINE2(1:LEN2),KB,B,*40,*50)
   20 CONTINUE
      NUM    = .TRUE.
      LT1    = KEYA(KA-1)
      LT2    = KEYB(KB-1)
      IF (LT1*LT2.EQ.0)  GO TO 50
 
      IF ((ABS(A-B).LE.TOL2.AND..NOT.EOR) .OR.
     +    (ABS(A).LE.TOL1.AND.ABS(B).LE.TOL1.AND..NOT.EOR) .OR.
     +    (ABS(A).GE.TOL3.AND.ABS(B).GE.TOL3.AND..NOT.EOR)) THEN
C  NUMERIC VALUES ARE NEARLY EQUAL OR
C  INDIVIDUAL NUMBERS ARE VERY SMALL OR VERY LARGE.
        K1 = LT1 + 1
        K2     = LT2 + 1
        RETURN1
 
      END IF
C  NUMERIC BUT SIGNIFICANT DIFFERENCE BETWEEN TWO NUMBERS.
      RETURN
*
C  NO MORE NUMBERS LEFT IN EITHER OR BOTH LINES.
C  NONE IN LINE1.
   30 CONTINUE
      EOR    = .TRUE.
      GO TO 10
C  NONE IN LINE2.
   40 CONTINUE
      EOR    = .TRUE.
      GO TO 20
*
C  NON NUMERIC STRING IN ONE OR OTHER LINE.
   50 CONTINUE
      NUM    = .FALSE.
 
      RETURN
      END
C----------------------------------------------
*
      SUBROUTINE LISTF2(M, N1, I2)
*
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
C     ..
C     .. Scalar Arguments ..
      INTEGER M,N1
C     ..
C     .. Scalars in Common ..
      CHARACTER*(LINLEN) A,B,LINE1,LINE2
C     ..
C     .. Local Scalars ..
      INTEGER I,N, TEMP2, J , I2
C     ..
C     .. External Functions ..
      INTEGER READS
      EXTERNAL READS
C     ..
C     .. External Subroutines ..
      EXTERNAL PUTCH,ZMESS,ZPUTCH
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS
C     ..
C     .. Common blocks ..
      COMMON /B1/LINE1,LINE2,A,B
C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
C  PROVIDE PORTABLE RECORD BACKSPACING.
C
C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
C             FROM A READS CALL FOR EACH FILE
C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
C             EACH FILE
C  SAVLIN     SAVED LINES FOR EACH FILE
C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
C  INFO(2..)  THE LINE NUMBER
C
      INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
      COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
      CHARACTER*134  SAVLIN(100, 2)
      COMMON /STACKC/ SAVLIN
      SAVE
C     ..
      N      = ABS(N1)
      IF (N1 .GT. 0) THEN
        CALL BSPACE(2,M)
      END IF
 
      CALL ZMESS
     +('THE FOLLOWING LINES ARE NOT ALIGNED (COMPARISON):.', FDS(3))
      DO 20 I = M,N - 1
        TEMP2 = READS(2,LINE2,I2)
        IF (TEMP2.NE.0) THEN
          DO 21 J = 1,TEMP2
   21     CALL ZPUTCH(LINE2(J:J), FDS(3))
          CALL PUTCH(10, FDS(3))
        ENDIF
   20 CONTINUE
 
      TEMP2 = READS(2,LINE2,I2)
      IF (N1.LT.0) THEN
        DO 22 J = 1,TEMP2
   22   CALL ZPUTCH(LINE2(J:J), FDS(3))
        CALL PUTCH(10, FDS(3))
        CALL ZMESS('END OF STANDARD FILE.', FDS(3))
      END IF
 
      RETURN
      END
C----------------------------------------------
*
      SUBROUTINE SHRINK
*
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
C     ..
C     .. Scalars in Common ..
      INTEGER L1,L1TOT,L2,L2TOT
      CHARACTER * (LINLEN)  A,B,LN1,LN2
C     ..
C     .. Arrays in Common ..
      INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
C     ..
C     .. Local Scalars ..
      INTEGER I
C     ..
C     .. Common blocks ..
      COMMON L1,L2,L1TOT,L2TOT,KEY1,KEY2
      COMMON /B1/LN1,LN2,A,B
      COMMON /B2/KEYA,KEYB
      SAVE
C     ..
      L1TOT  = 0
      L2TOT  = 0
      DO 10 I = 1,L1
        IF (LN1(I:I).NE.' ') THEN
          L1TOT  = L1TOT + 1
          A(L1TOT:L1TOT)  = LN1(I:I)
          KEY1(L1TOT)  = I
          KEYA(I)  = L1TOT
 
        ELSE
          KEYA(I)  = 0
        END IF
 
   10 CONTINUE
      DO 20 I = 1,L2
        IF (LN2(I:I).NE.' ') THEN
          L2TOT  = L2TOT + 1
          B(L2TOT:L2TOT)  = LN2(I:I)
          KEY2(L2TOT)  = I
          KEYB(I)  = L2TOT
 
        ELSE
          KEYB(I)  = 0
        END IF
 
   20 CONTINUE
 
      RETURN
      END
C----------------------------------------------
*
      SUBROUTINE SEARCH(K1,K2)
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
C     ..
C     .. Scalar Arguments ..
      INTEGER K1,K2
C     ..
C     .. Scalars in Common ..
      INTEGER L1,L2,LA,LA1,LB,LB2
      CHARACTER * (LINLEN)  A,A1,B,B2
C     ..
C     .. Arrays in Common ..
      INTEGER KY1(LINLEN),KY2(LINLEN)
C     ..
C     .. Local Scalars ..
      INTEGER K,KA,KB,L,M,N
      LOGICAL INAREA,OUTBOX
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC INDEX
C     ..
C     .. Common blocks ..
      COMMON L1,L2,LA1,LB2,KY1,KY2,LA,LB
      COMMON /B1/A1,B2,A,B
      SAVE
C     ..
      OUTBOX = .FALSE.
      L      = 0
C   SPACES BETWEEN CHARACTER STRINGS ACT AS DELIMITERS.
      KA     = K1 - 1
      IF (K2 .GT.LB) THEN
        KB     = K2 - 1
 
      ELSE
        KB     = K2
      END IF
C  IS KA'TH CHARACTER IN A = KB'TH CHARACTER IN B ?
C  IF SO ARE NEXT PAIR OF CHARACTERS SAME ?
   10 CONTINUE
      IF (A(KA:KA) .EQ. B(KB:KB)) THEN
        IF (KA+1 .LE. LA .AND. KB+1 .LE. LB) THEN
          IF(A(KA+1:KA+1) .NE. B(KB+1:KB+1)) GO TO 20
        END IF
 
        K1     = KA
        K2     = KB
        GO TO 30
 
      END IF
*
C  CHARACTERS DON'T AGREE OR ONE OR OTHER LINES AT END
C  OR SECOND CHARACTER DOESN'T AGREE
*
C  ARE WE WITHIN 3 CHARACTERS OF EITHER END
C  OR WITHIN THE 3 CHARACTER SEARCH AREA OF THE ENTRY POINT ?
C  CHECK UPTO 8 POSSIBLE COMBINATIONS TO FIND COMPARISON.
   20 CONTINUE
      INAREA = (KA.LE.K1+1) .AND. (KB.LE.K2+1)
      IF (KA+2 .GT. LA .OR. KB+2 .GT. LB .OR. INAREA) THEN
        KB     = KB + 1
        IF((KB.LE.LB.AND.(KB.LE.K2+1)).OR.(KB.LE.LB.AND.OUTBOX)) GOTO 10
        KA = KA + 1
        IF((KA.LE.LA.AND.(KA.LE.K1+1)) .OR. (KA.LE.LA.AND.OUTBOX)) THEN
C  L RESET TO 0 WHEN KA LEAVES BOX FOR SECOND TIME
          IF (L.EQ.3 .AND. .NOT. (KA.LE.K1+1)) L      = 0
          KB     = K2 - 1 + L
          GO TO 10
*
C  OUT OF THE BOX SEARCH AREA
C  NOW CHECK END OF BOTH OR EITHER LINE.
        ELSE IF (KA.GT.LA .AND. KB.GT.LB) THEN
          K1     = LA + 1
          K2     = LB + 1
          GO TO 30
C  ARE WE AT THE END OF LINE A ONLY OR AT NEITHER END ?
        ELSE IF (KA.GT.LA .OR. KB.LE.LB) THEN
C  RESET POINTER FOR LINE A BUT LEAVE POINTER FOR LINE B.
C  L SET TO 3 TO PREVENT REPEATING CHECKS IN BOX.
          OUTBOX = .TRUE.
          L      = 3
          KA     = K1 - 1
C  ARE WE AT THE END OF LINE B ONLY ? - YES !
        ELSE
C  RESET POINTER FOR LINE B BUT LEAVE POINTER FOR LINE A.
          OUTBOX = .TRUE.
          KB     = K2 - 1
        END IF
 
        GO TO 10
*
C  CAN'T FIND SINGLE CHARACTER COMPARISON
C  CHECK SUCCESSIVE GROUPS OF 3 CHARACTERS IN REST OF LINE.
      ELSE
        N      = INDEX(B(KB:LB),A(KA:KA+2))
        IF (N.EQ.0) THEN
          KA     = KA + 1
          KB     = K2 - 1
          GO TO 10
 
        END IF
 
        K1     = KA
        K2     = N + KB - 1
      END IF
   30 CONTINUE
 
      RETURN
      END
C----------------------------------------------
      LOGICAL FUNCTION SAME(K1,K2)
C   SETS LT1,LT2 TO POSITION OF CHARACTER BEFORE NEXT SPACE OR
C   END OF LINE IN ORIGINAL LINES.
C   THUS SPACES BETWEEN CHARACTER STRINGS WILL ACT AS DELIMITERS.
C     .. Parameters ..
      INTEGER LINLEN
      PARAMETER (LINLEN=134)
C     ..
C     .. Scalar Arguments ..
      INTEGER K1,K2
C     ..
C     .. Scalars in Common ..
      INTEGER L1TOT,L2TOT,LEN1,LEN2,LT1,LT2
      CHARACTER * (LINLEN)  A,A1,B,B2
C     ..
C     .. Arrays in Common ..
      INTEGER KEY1(LINLEN),KEY2(LINLEN)
C     ..
C     .. Local Scalars ..
      INTEGER KA,KB,N
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC INDEX
C     ..
C     .. Common blocks ..
      COMMON LEN1,LEN2,L1TOT,L2TOT,KEY1,KEY2,LT1,LT2
      COMMON /B1/A1,B2,A,B
      SAVE
C     ..
      IF (K1.GT.LT1) THEN
        KA     = KEY1(K1)
        N      = INDEX(A1(KA:LEN1),' ')
        IF (N.EQ.0) THEN
          LT1    = L1TOT
 
        ELSE
          LT1    = K1 + N - 2
        END IF
 
      END IF
 
      IF (K2.GT.LT2) THEN
        KB     = KEY2(K2)
        N      = INDEX(B2(KB:LEN2),' ')
        IF (N.EQ.0) THEN
          LT2    = L2TOT
 
        ELSE
          LT2    = K2 + N - 2
        END IF
 
      END IF
 
      SAME   = A(K1:K1) .EQ. B(K2:K2)
      K1     = K1 + 1
      K2     = K2 + 1
 
      RETURN
      END
C----------------------------------------------
C
C    READS A SINGLE NUMBER IN FREE FORMAT FROM INTERNAL BUFFER RECORD
C
      SUBROUTINE FREAD(RECORD,I,A,*,*)
C     .. Scalar Arguments ..
      DOUBLE PRECISION A
      INTEGER I
      CHARACTER * (*)  RECORD
C     ..
C     .. Scalars in Common ..
      LOGICAL COM,LBRKT
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION B,C,CC
      INTEGER EPOS,J,L,MAXREC,NEXP,P10,PPOS,SIGN
      LOGICAL EXNUM,EXPO,LB,NUMB,PMSIGN,POINT
      CHARACTER *18 CH
C     ..
C     .. Local Arrays ..
      CHARACTER D(0:17)
C     ..
C     .. External Functions ..
      LOGICAL SPSKIP
      EXTERNAL SPSKIP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC ABS,LEN,NINT
C     ..
C     .. Common blocks ..
      COMMON /ZFRDSV/ LBRKT, COM
      SAVE
C     ..
C     .. Equivalences ..
      EQUIVALENCE (CH,D)
C     ..
      DATA CH/'0123456789+-.EDed '/
*
      LB     = .FALSE.
      MAXREC = LEN(RECORD)
C  SKIP SPACES.
   10 CONTINUE
      IF (SPSKIP(RECORD,I)) THEN
        LBRKT  = .FALSE.
        I      = MAXREC + 1
 
      ELSE
        GO TO 20
 
      END IF
 
      RETURN1
 
   20 CONTINUE
C  CHECK TO SEE IF EITHER ( OR , ARE BEING USED AS DELIMITERS.
      IF (RECORD(I:I).EQ.',') THEN
C  ,, OR (, CONSIDERED AN ERROR.
        IF (COM .OR. (LBRKT.AND.LB)) GO TO 120
        COM    = .TRUE.
        I      = I + 1
        GO TO 10
 
      ELSE IF (RECORD(I:I).EQ.'(') THEN
C  ,( OR (( CONSIDERED AN ERROR.
        IF (COM .OR. LBRKT) GO TO 120
        I      = I + 1
        LBRKT  = .TRUE.
        LB     = .TRUE.
        GO TO 10
 
      ELSE IF (RECORD(I:I).EQ.')') THEN
C  (...) CONSIDERED OK, BUT () OR ) ON ITS OWN IS AN ERROR.
        IF (LBRKT .AND. .NOT. LB) THEN
          I      = I + 1
          LBRKT  = .FALSE.
 
        ELSE
          GO TO 120
 
        END IF
 
        GO TO 10
 
      END IF
C
C  FOUND NON SPACE CHARACTER WHICH IS NOT , ( OR )
C  TRY AND INTERPRET AS NUMBER.
C
      COM    = .FALSE.
      PMSIGN = .FALSE.
      POINT  = .FALSE.
      NUMB   = .FALSE.
      EXPO   = .FALSE.
      EXNUM  = .FALSE.
      SIGN   = 1
      B      = 0.0D0
      C      = 0.0D0
      P10    = 0
      L      = I
   30 CONTINUE
      I      = L
      IF (I.GT.MAXREC) THEN
        LBRKT  = .FALSE.
        GO TO 100
      END IF
 
      DO 90 J = 0,17
        IF (RECORD(I:I) .EQ. D(J)) THEN
          L      = L + 1
          IF (J.LE.9) THEN
            IF (POINT .AND. .NOT. EXPO) P10    = PPOS - I
            B      = B * 1.0D1 + DBLE(J)
            IF (EXPO) THEN
              EXNUM  = .TRUE.
 
            ELSE
              NUMB   = .TRUE.
              C      = DBLE(SIGN) * B
            END IF
 
          ELSE
            GO TO (40,50,60,70,70,70,70,80),J - 9
C  + SIGN OR SPACE AFTER E OR D.
   40       CONTINUE
            IF (PMSIGN) GO TO 120
            SIGN   = 1
            PMSIGN = .TRUE.
            GO TO 30
C  - SIGN.
   50       CONTINUE
            IF (PMSIGN) GO TO 120
            SIGN   = -1
            PMSIGN = .TRUE.
            GO TO 30
C  . IN MANTISSA.
   60       CONTINUE
            IF (POINT) GO TO 120
            PPOS   = I
            POINT  = .TRUE.
            PMSIGN = .TRUE.
            GO TO 30
C  E OR D INITIATING EXPONENT (UPPER OR LOWER CASE)
   70       CONTINUE
            IF (EXPO .OR. .NOT. NUMB) GO TO 120
            C      = DBLE(SIGN) * B
            B      = 0.0D0
            EXPO   = .TRUE.
            EPOS   = I
            SIGN   = 1
            PMSIGN = .FALSE.
            GO TO 30
C  SPACE SIGNIFYING EITHER END OF NUMBER OR POSITIVE EXPONENT.
   80       CONTINUE
            IF (EXPO) THEN
C  POSSIBLE EXPONENT CONFIGURATIONS...
C        E SPACE       (GET NEXT CHARACTER) OR...
              IF (I-1.EQ.EPOS) GO TO 30
C        E +/-   SPACE (ERROR) OR...
C        E NUM   SPACE (END OF NUMBER) OR...
C        E SPACE SPACE (GET NEXT CHARACTER) OR...
              IF (I-2.EQ.EPOS) THEN
                IF (PMSIGN) GO TO 120
                IF (EXNUM) GO TO 100
                GO TO 30
 
              END IF
C        E SPACE SPACE SPACE (ERROR) OR...
C        E SPACE =/-   SPACE (ERROR)
C  THREE SPACES AFTER E OR D IS ILLEGAL NUMBER,
C  SPACE AFTER SIGN IS ERROR.
              IF (I-3.EQ.EPOS .AND. .NOT. EXNUM) THEN
                IF ( .NOT. PMSIGN) I = EPOS + 1
                GO TO 120
              END IF
 
            ELSE
C  SIGN FOLLOWED BY SPACE IS ERROR
              IF (PMSIGN .AND. .NOT. NUMB) GO TO 120
            END IF
            GO TO 100
 
          END IF
          GO TO 30
 
        END IF
   90 CONTINUE
C
C  NUMBER MUST HAVE BEEN READ AT THIS POINT.
C  IF NEXT CHARACTER IS , OK.
C  IF NEXT CHARACTER IS ) AND NO OUTSTANDING ( THEN ERROR.
C  IF NEXT CHARACTER ( AND NO OUTSTANDING ( THEN OK.
C
      IF (RECORD(I:I).EQ.',') THEN
        I      = I + 1
        COM    = .TRUE.
        GO TO 100
      ELSE IF (RECORD(I:I).EQ.')') THEN
        IF (LBRKT) THEN
          LBRKT  = .FALSE.
          I      = I + 1
          GO TO 100
        END IF
      ELSE IF (RECORD(I:I).EQ.'(') THEN
        IF ( .NOT. LBRKT) THEN
          LBRKT  = .TRUE.
          I      = I + 1
          GO TO 100
        END IF
      END IF
 
      GO TO 120
C
C  ASSEMBLE NUMBER.
C
  100 CONTINUE
      IF ( .NOT. NUMB) THEN
        IF (EXPO) I = EPOS
        GO TO 120
      END IF
 
      IF (EXPO) THEN
        IF (.NOT. EXNUM) GO TO 120
        P10 = P10 + NINT(SIGN*B)
      END IF
C
C  NORMALIZE NUMBER
C
      CC     = C
      NEXP   = P10
  110 CONTINUE
      IF (ABS(CC).GE.10.0D0) THEN
        CC     = CC/10.0D0
        NEXP   = NEXP + 1
        GO TO 110
 
      ELSE IF (ABS(CC).LT.0.1D0 .AND. ABS(CC).GT.1.0D- 300) THEN
        CC     = CC*10.0D0
        NEXP   = NEXP - 1
        GO TO 110
 
      END IF
C
C  CHECK FOR OVERFLOW OR UNDERFLOW
C
      IF (NEXP.GT.300 .OR. NEXP.EQ.300 .AND. ABS(CC).GT.1.0D0) THEN
        P10    = 300
        C      = 0.99999999999999D0
 
      ELSE IF(NEXP.LT. - 300 .OR.
     +        NEXP.EQ. - 300 .AND. ABS(CC).LT.1.0D0)THEN
        A      = 0.0D0
        RETURN
 
      ELSE
        C      = CC
        P10    = NEXP
      END IF
 
      A      = C * 10.0D0**P10
      RETURN
C
C  NON NUMERIC VALUE.
C
  120 CONTINUE
      RETURN2
 
      END
C----------------------------------------------
C
C   GIVES LENGTH OF CHARACTER VARIABLE LESS END SPACES
C
      INTEGER FUNCTION LENG(A)
C     .. Scalar Arguments ..
      CHARACTER*(*) A
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC LEN
C     ..
      LENG=LEN(A)
   10 IF (A(LENG:LENG).EQ.' ' .AND. LENG.GT.1) THEN
          LENG=LENG-1
          GOTO 10
      END IF
 
      END
C----------------------------------------------
C
C   SKIPS TO NEXT NON-SPACE CHARACTER IN INTERNAL FILE
C
      LOGICAL FUNCTION SPSKIP(RECORD,K)
*
C     .. Scalar Arguments ..
      INTEGER K
      CHARACTER * (*)  RECORD
C     ..
C     .. Local Scalars ..
      INTEGER L
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC LEN
C     ..
      L      = LEN(RECORD)
      IF (K.GT.L) THEN
        K      = 1
        SPSKIP = .TRUE.
        RETURN
 
      END IF
 
   10 CONTINUE
      IF (RECORD(K:K).EQ.' ') THEN
        K      = K + 1
        IF (K.LE.L) GO TO 10
        K      = 1
        SPSKIP = .TRUE.
 
      ELSE
        SPSKIP = .FALSE.
      END IF
      END
C---------------------------------------------------------------------
C
      SUBROUTINE NAMES(OPT, PATH)
 
      INTEGER PATH(*), MSG1(16), MSG2(18), MSG3(14)
      INTEGER STAT, OPT, I
 
      INTEGER ZGTCMD
      EXTERNAL ZGTCMD,ZPRMPT
 
      DATA (MSG1(I),I=1,16)/83,116,97,110,100,97,114,100,
     +                      32,102,105,108,101,58,32,129/
      DATA (MSG2(I),I=1,18)/67,111,109,112,97,114,105,115,
     +             111,110,32,102,105,108,101,58,32,129/
      DATA (MSG3(I),I=1,14)/79,117,116,112,117,116,32,
     +                      102,105,108,101,58,32,129/
 
      IF(OPT .EQ. 1) CALL ZPRMPT(MSG1)
      IF(OPT .EQ. 2) CALL ZPRMPT(MSG2)
      IF(OPT .EQ. 3) CALL ZPRMPT(MSG3)
      STAT = ZGTCMD(PATH, 0)
 
      RETURN
      END
C---------------------------------------------------------------------
C
C  IDENTIFY OPTIONS
C
C     M     MAX LINES FORWARD TO RESYNC
C     S     SPACE SIGNIFICANCE
C     E     EXACT
C     H     HEADERS
C     T     TOLERANCES
C     R     RESYNC MARKER
C     F     FOLDING
C
      SUBROUTINE IDOPS(BUFFER)
 
      INTEGER C, I, LIMIT, POINT
      INTEGER BUFFER(*), LHS(134), RHS(134)
      CHARACTER CC
      CHARACTER*134 TEMPL
      CHARACTER*4 MARKER
      INTEGER II1, II2, NERROR, MAXFWD
      LOGICAL SPNULL, EXACT, HEADER, FOLD, VERBOS
      DOUBLE PRECISION T(3), VAL
      COMMON /TOLS/  T
      COMMON /ONLNE/ II1, II2, NERROR, EXACT
      COMMON /OPTSC/ MARKER
      COMMON /OPTSI/ MAXFWD, SPNULL, HEADER, FOLD, VERBOS
      SAVE
 
      INTEGER ZLOWER, LENGTH, CTOI, INDEXX
      CHARACTER ZCITOC
      EXTERNAL CTOI,INDEXX,LENGTH,ZCITOC,ZLOWER,ZSPLIT
 
      I = 1
      C = ZLOWER(BUFFER(1))
      CALL ZSPLIT(BUFFER, LHS, RHS)
      LIMIT = LENGTH(RHS)
 
      IF(C .EQ. 109) THEN
        MAXFWD = CTOI(RHS, I)
        IF(MAXFWD .LT. 2)  MAXFWD = 2
        IF(MAXFWD .GT. 99) MAXFWD = 99
 
      ELSE IF(C .EQ. 115) THEN
        SPNULL = .NOT. SPNULL
 
      ELSE IF(C .EQ. 101) THEN
        EXACT = .NOT. EXACT
 
      ELSE IF(C .EQ. 104) THEN
        HEADER = .NOT. HEADER
 
      ELSE IF(C .EQ. 116) THEN
        C = BUFFER(2)
        DO 5 I = 1, LIMIT
    5   TEMPL(I:I) = ZCITOC(RHS(I), CC)
        I = 1
        CALL FREAD(TEMPL(1:LIMIT), I, VAL, *10, *10)
        IF(C .EQ. 49) THEN
          T(1) = VAL
        ELSE IF(C .EQ. 51) THEN
          T(3) = VAL
        ELSE
          T(2) = VAL
        ENDIF
 
      ELSE IF(C .EQ. 114) THEN
        MARKER(1:4) = '    '
        POINT = INDEXX(BUFFER, 61)
        DO 20 I = 1, 4
          IF(BUFFER(I+POINT) .EQ. 129) GO TO 21
          MARKER(I:I) = ZCITOC(BUFFER(I+POINT), CC)
   20   CONTINUE
   21   CONTINUE
 
      ELSE IF(C .EQ. 102) THEN
        FOLD = .NOT. FOLD
 
      ELSE IF(C .EQ. 118) THEN
        VERBOS = .NOT. VERBOS
 
      ENDIF
 
   10 CONTINUE
 
      RETURN
      END
C-------------------------------------------------------
C
C  A RATHER SIMPLISTIC REAL NUMBER OUTPUT ROUTINE, THE NUMBER
C  ACTUALLY PRINTED MAY NOT BE QUITE CORRECT DUE TO ERRORS
C  INTRODUCED WHILST SCALING.
C
      SUBROUTINE OUTREL(VAL, FD)
 
      INTEGER FD, EXP
      DOUBLE PRECISION   VAL, TEMP
 
      EXTERNAL PUTCH,ZCHOUT,ZPTINT
 
      TEMP = ABS(VAL)
      IF(VAL .LT. 0) THEN
        CALL PUTCH(45, FD)
      ELSE IF(VAL .EQ. 0) THEN
        CALL ZCHOUT('0..0.', FD)
        RETURN
      ENDIF
 
      EXP = 0
   10 CONTINUE
        IF(TEMP .GT. 10.0D0) THEN
          TEMP = TEMP / 10.0D0
          EXP = EXP + 1
        ELSE IF(TEMP .LT. 1.0D0) THEN
          TEMP = TEMP * 10.0D0
          EXP = EXP - 1
        ELSE
          GO TO 20
        ENDIF
      GO TO 10
 
   20 CONTINUE
      CALL ZPTINT(INT(TEMP), 1, FD)
      TEMP = (TEMP - INT(TEMP)) * 1000.0D0
      CALL PUTCH(46, FD)
      CALL ZPTINT(INT(TEMP), 1, FD)
      CALL PUTCH(69, FD)
      CALL ZPTINT(EXP, 1, FD)
 
      RETURN
      END
C---------------------------------------------------
C
C  REPLACE THE READ STATEMENT.....THIS IS NECESSARY
C  BOTH FOR THE PORTABILITY ISSUE AND TO ALLOW FOR
C  BACKSPACING (REALLY MEANS GOING BACK MULTIPLE LINES
C  IN THIS CONTEXT).
C
C  FILE    THE FILE TO BE READ
C  LINE    THE RETURNED LINE
C  READS   EOF TO INDICATE AN ERROR OR END-OF-FILE CONDITION,
C          OTHERWISE LENGTH OF LINE READ
C
C  A BUFFER OF UP TO 100 LINES IS MAINTAINED FOR EACH INPUT FILE.
C  THESE ARE USED AS RING BUFFERS SO THAT BACKSPACE CAN BE IMPLEMENTED.
C
      INTEGER FUNCTION READS(FILE, LINE, NUMB)
 
      INTEGER       FILE, STATUS, I, POINT, C, MAXFWD, NUMB, J
      LOGICAL       SPNULL, HEADER, FOLD, VERBOS
      CHARACTER*(*) LINE
 
      COMMON /OPTSI/ MAXFWD, SPNULL, HEADER, FOLD, VERBOS
C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
C  PROVIDE PORTABLE RECORD BACKSPACING.
C
C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
C             FROM A READS CALL FOR EACH FILE
C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
C             EACH FILE
C  SAVLIN     SAVED LINES FOR EACH FILE
C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
C  INFO(2..)  THE LINE NUMBER
C
      INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
      COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
      CHARACTER*134  SAVLIN(100, 2)
      COMMON /STACKC/ SAVLIN
      SAVE
 
      INTEGER       ZGETLN, ZLOWER, ZCCTOI
      CHARACTER     ZCITOC
      EXTERNAL      ERROR,ZCCTOI,ZCITOC,ZGETLN,ZLOWER
 
      IF(NXTOUT(FILE) .GE. NXTIN(FILE)) THEN
        STATUS = ZGETLN(SAVLIN(NXTLIN(FILE), FILE), FDS(FILE))
        IF(STATUS .EQ. -1) STATUS = -100
        INFO(1, NXTLIN(FILE), FILE) = STATUS
        INFO(2, NXTLIN(FILE), FILE) = NXTIN(FILE)
        NXTIN(FILE) = NXTIN(FILE) + 1
        NXTLIN(FILE) = NXTLIN(FILE) + 1
        IF(NXTLIN(FILE) .GT. 100) NXTLIN(FILE) = NXTLIN(FILE) - 100
      ENDIF
 
      NUMB = NXTOUT(FILE)
 
      DO 10 I = 1, 100
        POINT = NXTLIN(FILE) - I
        IF(POINT .LE. 0) POINT = POINT + 100
        IF(INFO(2, POINT, FILE) .EQ. NXTOUT(FILE)) THEN
          READS = INFO(1, POINT, FILE)
          IF(READS .EQ. -100) RETURN
          NXTOUT(FILE) = NXTOUT(FILE) + 1
          LINE = SAVLIN(POINT, FILE)
          IF(FOLD) THEN
            DO 20 J = 1, READS
              C = ZLOWER(ZCCTOI(LINE(J:J), C))
              LINE(J:J) = ZCITOC(C, LINE(J:J))
   20       CONTINUE
          ENDIF
          RETURN
        ENDIF
   10 CONTINUE
      CALL ERROR('READS: REQUESTED LINE UNAVAILABLE.')
 
      RETURN
      END
C------------------------------------------------------
C
C  BACKSPACE A FILE. MORE CORRECTLY MOVE TO A SPECIFIED
C  INPUT LINE.
C
      SUBROUTINE BSPACE(FILE, LINE)
 
      INTEGER FILE, LINE
C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
C  PROVIDE PORTABLE RECORD BACKSPACING.
C
C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
C             FROM A READS CALL FOR EACH FILE
C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
C             EACH FILE
C  SAVLIN     SAVED LINES FOR EACH FILE
C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
C  INFO(2..)  THE LINE NUMBER
C
      INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
      COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
      CHARACTER*134  SAVLIN(100, 2)
      COMMON /STACKC/ SAVLIN
      SAVE
 
      EXTERNAL ERROR
 
      IF(LINE .LE. 0) CALL ERROR('ILLEGAL BACKSPACE REQUESTED.')
      NXTOUT(FILE) = LINE
 
      RETURN
      END
